let syntax_error = [
	"B22001A.ADT";
	"B22001B.ADT";
	"B22001C.ADT";
	"B22001D.ADT";
	"B22001E.ADT";
	"B22001F.ADT";
	"B22001G.ADT";
	"B22001H.ADA";
	"B22001I.ADT";
	"B22001J.ADT";
	"B22001K.ADT";
	"B22001L.ADT";
	"B22001M.ADT";
	"B22001N.ADT";
	"B23004A.ADA";
	"B23004B.ADA";
	"B24001A.ADA";
	"B24001B.ADA";
	"B24001C.ADA";
	"B24005A.ADA";
	"B24005B.ADA";
	"B24009B.ADA";
	"B24007A.ADA";
	"B24104A.ADA";
	"B24204A.ADA";
	"B24204B.ADA";
	"B24204C.ADA";
	"B24204D.ADA";
	"B24204E.ADA";
	"B24204F.ADA";
	"B24205A.ADA";
	"B24206A.ADA";
	"B24206B.ADA";
	"B24211B.ADA";
	"B25002A.ADA";
	"B25002B.ADA";
	"B26001A.ADA";
	"B26002A.ADA";
	"B26005A.ADA";
	"B28001A.ADA";
	"B28001B.ADA";
	"B28001C.ADA";
	"B28001D.ADA";
	"B28001E.ADA";
	"B28001S.ADA"; (* pragma before case alternatives *)
	"B28001T.ADA";
	"B28001U.ADA";
	"B28001V.ADA";
	"B28001W.ADA"; (* pragma before exception alternatives *)
	"B29001A.ADA";
	"B2A003A.ADA";
	"B2A003B.ADA";
	"B2A003C.ADA";
	"B2A003D.ADA";
	"B2A003E.ADA";
	"B2A003F.ADA";
	"B2A005A.ADA";
	"B2A005B.ADA";
	"B2A007A.ADA";
	"B2A010A.ADA";
	"B2A021A.ADA";
	"B33201B.ADA"; (* violate RM 4.8. it should not be parser error. *)
	"B35101A.ADA";
	"B36171C.ADA";
	"B36171D.ADA";
	"B36171E.ADA";
	"B37201B.ADA";
	"B393002.A";
	"B44001A.ADA";
	"B44004A.ADA"; (* var := (... in ... range ...); *)
	"B44004B.ADA"; (* var := (... in ... digits ...); *)
	"B44004C.ADA"; (* var := (... in ... delta ...); *)
	"B45205A.ADA";
	"B53001A.ADA";
	"B53001B.ADA";
	"B53002A.ADA"; (* else before elsif *)
	"B53002B.ADA"; (* else before elsif *)
	"B54A01B.ADA";
	"B54A01F.ADA";
	"B54A01G.ADA";
	"B55A01A.ADA";
	"B55A01D.ADA";
	"B55A01E.ADA";
	"B55A01J.ADA";
	"B55A01K.ADA";
	"B55A01L.ADA";
	"B55A01N.ADA";
	"B55A01O.ADA";
	"B55A01T.ADA";
	"B55A01U.ADA";
	"B55A01V.ADA";
	"B55B17A.ADA";
	"B55B17B.ADA";
	"B55B17C.ADA";
	"B56001D.ADA";
	"B56001F.ADA";
	"B56001H.ADA";
	"B61001F.ADA";
	"B62001C.ADA";
	"B62001D.ADA";
	"B64004B.ADA";
	"B64004C.ADA";
	"B64004D.ADA";
	"B64004E.ADA";
	"B64004F.ADA";
	"B91001C.ADA";
	"B91001D.ADA"; (* task unit *)
	"B91001E.ADA"; (* task unit *)
	"B95001D.ADA";
	"B95003A.ADA";
	"B95004A.ADA";
	"B95006B.ADA"; (* accept ... end T.E1; *)
	"B95006C.ADA"; (* accept ... end T.E1; *)
	"B95006D.ADA";
	"B95061G.ADA";
	"B95082B.ADA";
	"B95082C.ADA";
	"B95082D.ADA";
	"B95082E.ADA";
	"B95082F.ADA";
	"B952003.A";
	"B97102H.ADA";
	"B97102I.ADA";
	"B97103E.ADA";
	"B97104A.ADA";
	"B97104B.ADA";
	"B97104C.ADA";
	"B97104D.ADA";
	"B97104E.ADA";
	"B97104F.ADA";
	"B97104G.ADA";
	"B97108A.ADA";
	"B97108B.ADA";
	"B9A001A.ADA";
	"BA150022.A";
	"BA150024.A";
	"BA150026.A";
	"BA150028.A";
	"BC1008A.ADA";
	"BC1008B.ADA";
	"BC1008C.ADA";
	"BC1016A.ADA"; (* generic task *)
	"BC1016B.ADA"; (* generic task *)
	"BC2001D.ADA"; (* generic task *)
	"BC2001E.ADA"; (* generic task *)
	"BC1202E.ADA";
	"BC51016.A";
	"BC51017.A";
	"BC51018.A";
	"BD8002A.ADT"];; (* $OPTIONAL_DISC *)

let not_syntax_error = [
	"B23002A.ADA"; (* identifier like _A, A_ *)
	"B24009A.ADA"; (* type check *)
	"B28001F.ADA"; (* missing statement *)
	"B28001G.ADA"; (* missing statement *)
	"B28001H.ADA"; (* missing statement *)
	"B28001I.ADA"; (* missing statement *)
	"B28001J.ADA"; (* missing statement *)
	"B28001K.ADA"; (* missing statement *)
	"B28001L.ADA"; (* missing statement *)
	"B28001M.ADA"; (* missing statement *)
	"B28001N.ADA"; (* missing statement *)
	"B28001O.ADA"; (* missing statement *)
	"B28001P.ADA"; (* missing statement *)
	"B28001Q.ADA"; (* missing statement *)
	"B28001R.ADA"; (* missing component declaration *)
	"B32103A.ADA"; (* uninitialized constant *)
	"B32104A.ADA"; (* uninitialized unconstrained array *)
	"B32106A.ADA"; (* type mismatch *)
	"B32201A.ADA"; (* non-numeric untyped constant *)
	"B32202A.ADA"; (* type mismatch *)
	"B32202B.ADA"; (* type mismatch *)
	"B32202C.ADA"];; (* type mismatch *)

if List.exists (fun s -> List.mem s syntax_error) not_syntax_error then (
	raise (Failure "Bad error or not error files list!")
);;

let show_token, skips, target = (
	let show_token = ref false in
	let skips = ref "" in
	let target = ref "" in
	let args = Stream.of_list (List.tl (Array.to_list Sys.argv)) in
	while Stream.peek args <> None do
		match Stream.next args with
		| "-v" ->
			show_token := true
		| "-w" ->
			Parser.debug := true
		| "--skip" ->
			skips := String.uppercase (Stream.next args)
		| _ as s when s.[0] = '-' ->
			raise (Failure ("Invalid option: " ^ s))
		| _ as path ->
			target := path
	done;
	!show_token, !skips, !target
);;

module Scanner = Scanner.Scanner (Stream);;

let test filename = (
	let ed = ref (("", 0, 0), Parser.Expected []) in
	let rec print_errors (es: (Scanner.text_file_position * Parser.error) list) = (
		let rec print_error ((p, e): Scanner.text_file_position * Parser.error) = (
			(* print_string (TextFilePosition.to_string p); *)
			let (f, l, c) = p in Printf.printf "%s:%d:%d" f l c;
			print_string ":";
			Parser.pp_error (Lexical.Token.pp ~paren:true ~quali:false) Format.std_formatter e;
			Format.print_flush ();
			print_newline ()
		) in
		begin match es with
		| e :: er ->
			if e != !ed then (
				print_errors er;
				print_error e;
				ed := e
			)
		| [] -> ()
		end
	) in
	let f = open_in_bin filename in
	let s = Scanner.create 3 filename (Stream.of_channel f) in
	let p = Parser.create () in
	let rec loop p = (
		let token, pos = Scanner.next s in
		if show_token then (
			let (_, l, c) = pos in
			Printf.printf " %d:%d " l c;
			Lexical.Token.pp ~quali:false ~paren:false Format.std_formatter token;
			Format.pp_print_flush Format.std_formatter ();
			print_newline ()
		);
		flush stdout;
		let p = Parser.post pos token p in
		flush stderr;
		if show_token then print_errors (Parser.errors p);
		if token <> Lexical.Token.Eof then loop p else p
	) in
	let p = loop p in
	close_in f;
	let errors = Parser.errors p in
	print_errors errors;
	let base_filename = Filename.basename filename in
	if errors <> [] then (
		if not (List.mem base_filename syntax_error) then (
			print_string "be not error.\n"; 
			exit 1
		)
	) else if base_filename.[0] = 'B' && base_filename.[1] = '2' then (
		if not (List.mem base_filename not_syntax_error) then (
			print_string "be error.\n"; 
			exit 1
		)
	)
);;

module StringMap = Map.Make (String);;

let is_word (c: char): bool = (
	match c with
	| 'A'..'Z' | 'a'..'z' | '_' | '0'..'9' -> true
	| _ -> false
);;

let read_macro (basedir: string): string StringMap.t = (
	let macro_file = Filename.concat basedir "SUPPORT/MACRO.DFS" in
	let f = open_in macro_file in
	let rec loop result = (
		try
			let line = input_line f in
			if line <> "" && is_word line.[0] then (
				let i = ref 0 in
				while is_word line.[!i] do
					incr i
				done;
				let name = String.sub line 0 !i in
				let right = String.length line in
				let right = (if line.[right - 1] = '\r' then right - 1 else right) in
				let value = String.sub line !i (right - !i) in
				loop (StringMap.add name value result)
			) else (
				loop result
			)
		with End_of_file -> result
	) in
	let result = loop StringMap.empty in
	close_in f;
	result
);;

let replace_macro ~(source: string) ~(dest: string) (macro: string StringMap.t): unit = (
	let s = open_in source in
	let d = open_out dest in
	let rec loop () = (
		try
			let line = ref (input_line s) in
			let i = ref 0 in
			while !i < String.length !line do
				if !line.[!i] = '-' && !i + 1 < String.length !line && !line.[!i + 1] = '-' then (
					i := String.length !line
				) else if !line.[!i] = '$' then (
					incr i;
					let start = !i in
					while !i < String.length !line && is_word !line.[!i] do
						incr i
					done;
					let key = String.sub !line start (!i - start) in
					line := String.sub !line 0 (start - 1) ^
						(try StringMap.find key macro with Not_found -> raise (Failure key)) ^
						String.sub !line !i (String.length !line - !i)
				) else (
					incr i
				)
			done;
			output_string d !line;
			output_char d '\n';
			loop ()
		with End_of_file -> ()
	) in
	loop ();
	close_in s;
	close_out d
);;

if not (Sys.is_directory target) then (
	print_string target;
	print_newline ();
	test target
) else if Sys.file_exists (Filename.concat target "SUPPORT/ACATS30.LST") then (
	let dir = Unix.opendir target in
	begin try
		let macro = read_macro target in
		while true do
			let subdir = Unix.readdir dir in
			if subdir.[0] <> '.' && not (String.contains skips subdir.[0]) then (
				print_string "in ";
				print_string subdir;
				print_newline ();
				let path = Filename.concat target subdir in
				let files = Unix.opendir path in
				begin try
					while true do
						let filename = Unix.readdir files in
						if Filename.check_suffix filename ".ADA"
							|| Filename.check_suffix filename ".A"
							|| Filename.check_suffix filename ".AM"
						then (
							print_string filename;
							print_newline ();
							test (Filename.concat path filename);
							Gc.minor ()
						) else if Filename.check_suffix filename ".TST" then (
							let adt = (Filename.chop_suffix filename ".TST") ^ ".ADT" in
							print_string filename;
							print_string " -> ";
							print_string adt;
							print_newline ();
							replace_macro ~source:(Filename.concat path filename) ~dest:adt macro;
							test adt;
							Gc.minor ()
						)
					done
				with
				| End_of_file -> Unix.closedir files
				end;
				Gc.major ()
			)
		done
	with 
	| End_of_file -> Unix.closedir dir
	end
) else (
	Printf.printf "There is not acats in %s.\n" target;
	exit 1
);;
